perm filename DRAWIT.F4[MSS,LCS] blob sn#066236 filedate 1974-01-08 generic text, type T, neo UTF8
00100		SUBROUTINE DRAWIT
00105		DIMENSION BUF2(1000)
00110		COMMON XX(100),YY(100),NQ,X1(512),Y1(512),SX(100)
00200		COMMON/ED/K,NEXT,NN,NX,NY,J
00300		COMMON /RZ/RSZ,IPLT,RJB,CENTR
00400		COMMON /RC/MCLEF(200),IST(4000),MFILL(200)
00500		COMMON/ZN/SCLEF(200,2),DDD
00600		COMMON/LL/LL
00610		COMMON/JJJ/JJJ
00700		EQUIVALENCE(MM,SCLEF(1,1)),(W,IST(4000)),(BUF2,IST(3001))
00800		DATA RN/15./,RND/0.5/
00900		CALL ACCPOG(1)
01000	C  DISPLAYS OLD ITEM WITHOUT FILLER
01100		CALL DPYOUT(1)
01200		REL=-1
01300		JC=0
01400		W=-1
01500		KE=-1
01600		JCL=0
01700		RJ=1
01800		JF=0
01900		IF(MM.EQ.0)GO TO 20
02000		J=MM
02100		JX=-1
02200		JCL=MM
02300		NX=SCLEF(MM,1)
02400		NY=SCLEF(MM,2)
02500		GO TO 120
02600	20	IF(JF.EQ.0)J=1
02900		JZ=J
03200	2	NX=RJB*RSZ
03300		NY=CENTR*RSZ
03500	121	JX=0
03600	120	NZ=-1
03700		JC=1
03800		RL=NX
03900		RM=NY
04000	C  L AND M ARE USED AS CONSTANTS WHEN RESETTING CURSOR
04100	44	CALL SETCUR(NX,NY,0)
04200	83	S=0
04300	4	IF(S)GO TO 81
04320		IF(K.EQ.'E')GO TO 700
04360	C  BYPASS FOR EDITING.
04400		TYPE 45
04500		ACCEPT 144,K,ZK
04600		IF(ZK.NE.'E')GO TO 344
04700		REL=0
04800	C  TYPE REL FOR RELATIVE VECTORS, O=ORDINARY
04900		GO TO 4
05000	344	IF(K.NE.'O')GO TO 244
05100		REL=-1
05200		GO TO 4
05300	144	FORMAT(2A1)
05310	244	IF(ZK.NE.'S')GO TO 444
05320		DO 544 K=1,JA
05330		CALL UNPACK(K,I,J,MCLEF)
05340		XX(K)=I
05350	544	YY(K)=J
05360		NQ=JA
05370		CALL SS
05380		CALL DPYSET(2,BUF2,1000)
05384		CALL AIVECT(IFIX(X1(1)),IFIX(Y1(1)))
05388		DO 555 K=2,512
05392	555	CALL AVECT(IFIX(X1(K)),IFIX(Y1(K)))
05396		CALL DPYOUT(2)
05398		GO TO 4
05400	444	REREAD 1,K,ZK,XK
05500		IF(K.LE.' ')GO TO 40
05600		REREAD 11,RJ,RK,XK
05700		JMPR=0
05800		IF(XK.NE.0)K='J'
05900	C  TYPE 3RD NUM=1 FOR JUMPS
06000	41	QJ=RJ
06100		QK=RK
06200		IF(REL)GO TO 141
06300	241	X=X+QJ*RSZ
06400		Y=Y+QK*RSZ
06500		NX=X
06600		NY=Y
06700		GO TO 48
06800	141	NX=GTPT(RJ,RJB)
06900		NY=GTPT(RK,CENTR)
07000		X=NX
07100		Y=NY
07200		GO TO 481
07300	40	KK=ZK
07400	C B=BACKUP, J=JUMP, CR=SET POINT, X=EXIT, LRUD-N
07500	C  F=FILL IT, H=GO TO HOME-NUM, N=GO TO NEXT(AFTER AN 'H')
07600	C  Z=ZERO IN ON NEARBY POINT, P=GO TO PREVIOUS, C=CLOSE THE AREA
07700	C  D=EXTEND DRAWING,  F=START FILLER OUTLINE, 
07800	C  TYPE 'F' FOR EACH AREA TO BE FILLED
07900		IF(ZK.NE.0)NZ=-1
08000	C  WILL STAY IN "Z" MODE UNLESS NUMBER APPEARS.
08100		JMPR=0
08200		JCX=2
08300	C  JCX IS FOR "ZEROING-IN" SECTION AND EDIT SECTION
08400	C  FOR SHIFTS OF "JUMPS"
08500		IF(K.EQ.'B')GO TO 22
08600		IF(K.EQ.'P')GO TO 56
08700		IF(K.EQ.'C')GO TO 51
08800		IF(K.EQ.'H')GO TO 52
08900		IF(K.EQ.'X'.OR.K.EQ.'F')GO TO 3
09000		IF(K.EQ.' '.OR.K.EQ.'J'.OR.K.EQ.'Z')GO TO 47
09100		IF(K.EQ.'S')GO TO 79
09200		IF(K.NE.'N')GO TO 7
09300	55	KK=NEXT
09400		GO TO 52
09500	56	KK=NEXT-2
09600	52	IF(KK.LE.1)KK=2
09700		X=SCLEF(KK,1)
09800		Y=SCLEF(KK,2)
09900		NEXT=KK+1
10000		IF(KE)GO TO 48
10100		RX=X
10200		RY=Y
10210	58	CALL ITYP
10300		CALL EDTYP(K,X,JJJ)
10600	C  TYPE "A" OR ":" TO ALTER
10800	C  TYPE "G"=GROUP CHANGE) TO MAKE RELATIVE CHANGE STICK
10850	C  , THEN <CR>S. ANY OTHER LETTER TO ESCAPE
11100	570	IF(K.EQ.' '.AND.S)GO TO 81
11300		IF(K.EQ.'S')GO TO 82
11400	C  S=STEP AHEAD(N) (-N GOES BACK)
11500		IF(K.EQ.'X')GO TO 44
11600		IF(W)MCLEF(1)=J
11700		IF(W.EQ.0)MFILL(1)=J
11800	571	CALL DREDIT
12100	59	X=RX
12200		Y=RY
12300		KE=-1
12320		NX=0
12340		NY=0
12400		GO TO 170
12500	C  THIS WRECKS "CLOSE"
12600	47	IF(REL.EQ.0)GO TO 22
12700	C  IF IN "REL" MODE TYPE "O" BEFORE USING LTPEN
12800		CALL RDCUR(NX,NY)
12900		X=NX
13000		Y=NY
13100		IF(K.NE.'Z'.AND.NZ)GO TO 48
13200		NZ=0
13300		DO 54 K=JCX,JCL
13400	      IF(ABS(SCLEF(K,1)-X).GT.RN.OR.ABS(SCLEF(K,2)-Y).GT.RN)
13500		1 GO TO 54
13600		KK=K
13700		GO TO 52
13800	54	CONTINUE
13900		IF(KE)GO TO 48
14000		TYPE 154
14100		GO TO 4
14200	154	FORMAT(' NO POINT FOUND ')
14400	C  ABOVE FOR INITIAL MOVEMENT OF CURSOR
14500	51	X=RX
14600		Y=RY
14700	48	RJ=STPT(X,RJB)
14800		RK=STPT(Y,CENTR)
14900	481	SK=RK
15000		J=J+1
15100		SJ=RJ
15200	C  DO I NEED RJ,RK ANYWHERE??  YES - AT REPACK
15300	451	LL=0
15400		IF(K.EQ.'J')LL=3
15500	C  J=JUMP
15600		IJ=RJ
15700		IK=RK
15800		IF(JF)GO TO 49
15900		JCL=J
16000		CALL REPACK(J,IJ,IK,MCLEF)
16100		IF(MCLEF(J).NE.MCLEF(J-1).OR.J.EQ.2)GO TO 60
16200	61	J=J-1
16300		GO TO 4
16400	60	SCLEF(J,1)=X
16500		SCLEF(J,2)=Y
16600		GO TO 50
16700	49	CALL REPACK(J,IJ,IK,MFILL)
16800		IF(MFILL(J).EQ.MFILL(J-1).AND.J.NE.2)GO TO 61
16900	50	N=IST(2)
17000		X=GTPT(SJ,RJB)
17100		Y=GTPT(SK,CENTR)
17200		NX=X
17300		NY=Y
17400		IF(K.EQ.'B')GO TO 5
17500		IF(K.EQ.'J'.OR.JMPR.OR.JX.EQ.0)GO TO 6
17600		CALL AVECT(NX,NY)
17700		GO TO 5
17800	6	CALL AIVECT(NX,NY)
17900		JX=-1
18000		JMPR=-1
18200	C  KZ IS FOR "CLOSE IT"
18300		NZ=-1
18400		RX=X
18500		RY=Y
18600	5	CALL DPYOUT(1)
18700		TYPE 46,J,SJ,SK
18800	
18900	170	CALL SETCUR(NX,NY,JC)
19000		GO TO 4
19010	72	FORMAT(' EDIT O(UTLINE) OR F(ILLER)? ',$)
19020	74	FORMAT(' S(TEP) OR L(IGHT PEN)? ',$)
19100	7	IF(K.NE.'E')GO TO 8
19200	C  E=EDIT 
19210	700	TYPE 72
19220		ACCEPT 1,K
19230		IF(K.EQ.'F')GO TO 73
19240		TYPE 74
19250		ACCEPT 1,K,X
19260		IF(K.NE.'L')GO TO 79
19300		IF(ZK.NE.0)JCX=ZK
19400	C  SETS "ZEROING-IN" FIRST COUNTER
19500		NZ=0
19600		KE=0
19700		TYPE 70
19800		GO TO 44
19900	70	FORMAT(' CHOOSE A POINT ')
20000	8	IF(K.NE.'W')GO TO 71
20100	73	NN=ZK
20150		JF=-1
20200		IF(MFILL(1).GT.0)CALL EDFILL
20210		IF(K.EQ.'F')GO TO 341
20220	C  TO ADD ON TO FILLER: TYPE  "E <CR>, F <CR>, F<CR>
20300		K='X'
20400	C  ALWAYS EXITS AFTER FILL-EDIT
20500		GO TO 34
20600	71	IF(ZK.EQ.0)ZK=1
20700		IF(K.EQ.'L'.OR.K.EQ.'D')ZK=-ZK
20900		IF(K.EQ.'L'.OR.K.EQ.'R')GO TO 77
21000		SK=ZK+SK
21100		Y=GTPT(SK,CENTR)
21200		GO TO 78
21300	77	SJ=ZK+SJ
21400		X=GTPT(SJ,RJB)
21500	78	IST(2)=IST(2)-1
21600		CALL HYDPOG(1)
21700		CALL ACCPOG(1)
21800		GO TO 451
21900	79	S=-1
22000		JA=ZK-1
22100	84	IF(JA.LT.2)JA=1
22200	81	IF(K.NE.'D')JA=JA+1
22300		X=SCLEF(JA,1)
22400		Y=SCLEF(JA,2)
22500		NX=X
22600		NY=Y
22700		NEXT=JA+1
22800		CALL SETCUR(NX,NY,0)
22900		GO TO 58
23000	82	IF(X.EQ.0)X=-1
23100		JA=JA-1+X
23200		GO TO 84
23300	22	IF(J.EQ.JZ)GO TO 4
23400	C  CAN'T BACKUP PAST 1 OR 'F'
23500		J=J-1
23600		IF(JF)GO TO 122
23700		CALL UNPACK(J,IJ,IK,MCLEF)
23800		GO TO 222
23900	122	CALL UNPACK(J,IJ,IK,MFILL)
24000	222	IST(2)=IST(2)-1
24100		SJ=IJ
24200		SK=IK
24300		CALL HYDPOG(1)
24400		CALL ACCPOG(1)
24500		IF(K.EQ.'B')GO TO 50
24600		RJ=RJ+QJ
24700		RK=RK+QK
24800		GO TO 241
24900	3	IF(JF.NE.0)GO TO 33
25000		MCLEF(1)=J
25100		IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
25200		GO TO 34
25300	33	MFILL(JZ)=J
25400		MFILL(1)=J
25500	34	CALL CLRCUR
25700		IF(K.EQ.'X')RETURN
25800	341	JF=JF-1
25900		JZ=J
26000		IF(JF.NE.-1)GO TO 340
26100		J=1
26200		JZ=0
26300	340	J=J+1
26400		JZ=JZ+1
26500		MFILL(J)=1000
26600	C  SO REPEAT TRAP IS BYPASSED WHEN 'F' IS TYPED
26700		JX=0
26800	C FOR  INVISIBLE VECTOR.
26900		JC=0
27000		GO TO 20
27100	1	FORMAT(A1,2F)
27200	11	FORMAT(3F)
27300	46	FORMAT(I3,'.)',2F6.0/)
27400	45	FORMAT(' <CR> SETS POINT ',$)
27500		END